home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Dynamic We219266292001.psc / WebServer.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  2001-06-30  |  10.3 KB  |  301 lines
  1. VERSION 5.00
  2. Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
  3. Object = "{6580F760-7819-11CF-B86C-444553540000}#1.0#0"; "EZFTP.OCX"
  4. Begin VB.Form frmWebserver 
  5.    Caption         =   "Home Web relinker"
  6.    ClientHeight    =   660
  7.    ClientLeft      =   165
  8.    ClientTop       =   735
  9.    ClientWidth     =   3690
  10.    Icon            =   "WebServer.frx":0000
  11.    LinkTopic       =   "Form1"
  12.    ScaleHeight     =   660
  13.    ScaleWidth      =   3690
  14.    ShowInTaskbar   =   0   'False
  15.    StartUpPosition =   3  'Windows Default
  16.    Begin EZFTPLib.EZFTP FTP 
  17.       Left            =   2160
  18.       Top             =   0
  19.       _Version        =   65536
  20.       _ExtentX        =   800
  21.       _ExtentY        =   800
  22.       _StockProps     =   0
  23.       LocalFile       =   ""
  24.       RemoteFile      =   ""
  25.       RemoteAddres    =   ""
  26.       UserName        =   ""
  27.       Password        =   ""
  28.       Binary          =   0   'False
  29.    End
  30.    Begin VB.PictureBox Picture1 
  31.       Height          =   615
  32.       Left            =   2640
  33.       Picture         =   "WebServer.frx":030A
  34.       ScaleHeight     =   555
  35.       ScaleWidth      =   555
  36.       TabIndex        =   2
  37.       Top             =   0
  38.       Width           =   615
  39.    End
  40.    Begin MSWinsockLib.Winsock WS1 
  41.       Left            =   1560
  42.       Top             =   0
  43.       _ExtentX        =   741
  44.       _ExtentY        =   741
  45.       _Version        =   393216
  46.    End
  47.    Begin VB.Label Label1 
  48.       Caption         =   "Label1"
  49.       ForeColor       =   &H8000000D&
  50.       Height          =   255
  51.       Left            =   1080
  52.       TabIndex        =   1
  53.       Top             =   120
  54.       Width           =   1215
  55.    End
  56.    Begin VB.Label IP 
  57.       Caption         =   "IP address: "
  58.       Height          =   255
  59.       Left            =   120
  60.       TabIndex        =   0
  61.       Top             =   120
  62.       Width           =   855
  63.    End
  64.    Begin VB.Menu mnuPWS 
  65.       Caption         =   "mnuPWS"
  66.       Begin VB.Menu mnuIPaddr 
  67.          Caption         =   "Your IP"
  68.          Enabled         =   0   'False
  69.       End
  70.       Begin VB.Menu mnuLine2 
  71.          Caption         =   "-"
  72.       End
  73.       Begin VB.Menu mnuAbout 
  74.          Caption         =   "About"
  75.       End
  76.       Begin VB.Menu mnuLine1 
  77.          Caption         =   "-"
  78.       End
  79.       Begin VB.Menu Settings 
  80.          Caption         =   "S&ettings"
  81.       End
  82.       Begin VB.Menu StartRelink 
  83.          Caption         =   "&Start"
  84.       End
  85.       Begin VB.Menu StopRelink 
  86.          Caption         =   "S&top"
  87.       End
  88.       Begin VB.Menu mnuLine 
  89.          Caption         =   "-"
  90.       End
  91.       Begin VB.Menu mnuExit 
  92.          Caption         =   "&Exit"
  93.       End
  94.    End
  95. Attribute VB_Name = "frmWebserver"
  96. Attribute VB_GlobalNameSpace = False
  97. Attribute VB_Creatable = False
  98. Attribute VB_PredeclaredId = True
  99. Attribute VB_Exposed = False
  100. '------------------------------------------------------------------------
  101. 'Program made by Peter Verburgh @ 2001
  102. 'First read the Readme_Web included in the zip file..
  103. 'This application let it make a dynamic Webserver..
  104. 'If you have a free account by provider ex. A , and you got some free webspace...
  105. 'but the provider wouldn't let you use the full advantage of free ASP.. PHP...
  106. 'and you have a PWS , IIS ,....
  107. 'You can now make your own webserver ..
  108. 'How it works..
  109. '-----------------
  110. 'you start this program .. then you can see a ico .. right down..,
  111. 'this application detects the ip adres..& then it  change some data in the index.html..
  112. 'local on your computer on drive.. x  (changable it by settings..)
  113. '& then it would be uploaded to your free web- provider..
  114. 'Next step is, i have written some very- easy code in index.html (javascript) hat reads the
  115. 'ip adres & the script detects if your webserver is online.. if its true ,
  116. 'the user navigates to your free account & the person will be directed to your webserver.
  117. '(standard port 80)... but you can change it in the javascript..'
  118. 'AND now you GOT THE FULL POWER... to do anythings...
  119. 'REMARK : its possible , that it wouldn't work if you have multiple IP , have installed on
  120. 'your pc... because WINSOCK.OCX use the default..
  121. 'you can handle it by binding...
  122. 'If the OCX file for ftp. isn't included in the file.. you can find it on my site (under construction)
  123. 'http://users.skynet.be/verburgh.peter
  124. 'Please Vote for me !!
  125. 'Tnx !!!!
  126. '-------------------------------------------------------------------------------------------------------
  127. Dim blnStart As Boolean
  128. Dim FileSend As Boolean
  129. Dim fs, f, Text
  130. Dim fso1, a
  131. Const ForReading = 1, ForWriting = 2, ForAppending = 3
  132. Private Sub Form_Load()
  133. Dim fso, msg
  134. '-------------------------------------------------------- check for local IP... --------------------
  135. ' if you have multiple IP installed on your pc , that way doesn't work.. because ,
  136. 'winsock takes the default value....
  137. 'In the future i will look to change it by API..
  138. Label1.Caption = WS1.LocalIP
  139. mnuIPaddr.Caption = WS1.LocalIP
  140. '---------------------------------------------------------
  141. 'Reading Inf file
  142. modSettings.ThisDir = CurDir
  143. modSettings.ThisDir = modSettings.ThisDir & "\"
  144. '----------------------------------------------------------------
  145. 'Check if file exist... otherwise make the file...
  146.    Set fso = CreateObject("Scripting.FileSystemObject")
  147.    If (fso.FileExists((modSettings.ThisDir & "DynaSetting.inf"))) Then
  148.       'File Exist...no problem.. error
  149.    Else
  150.       MsgBox "This is maybe the first time that you use this application , so you have to fill down the settings..", vbInformation
  151.         Dialog.Show
  152.        CreateIcon
  153.        StopRelink.Visible = False
  154.        Me.Hide
  155.        GoTo End1:
  156.    End If
  157. '---------------------------------------------------------------------------------------
  158. modSettings.strUrl = modINI.sGetINI(modSettings.ThisDir & "DynaSetting.inf", "Settings", "FTP", "?")
  159. modSettings.strLogin = modINI.sGetINI(modSettings.ThisDir & "DynaSetting.inf", "Settings", "Username", "?")
  160. modSettings.strPassword = modINI.sGetINI(modSettings.ThisDir & "DynaSetting.inf", "Settings", "Password", "?")
  161. modSettings.strSource = modINI.sGetINI(modSettings.ThisDir & "DynaSetting.inf", "Settings", "LocalFile", "?")
  162. modSettings.strRemote = modINI.sGetINI(modSettings.ThisDir & "DynaSetting.inf", "Settings", "RemoteFile", "?")
  163. '---------------------------------------------------------
  164. CreateIcon
  165. StopRelink.Visible = False
  166. Me.Hide
  167. End1:
  168. End Sub
  169. Sub SendFiletoServer()
  170. 'This error handling => tnx to AutoBot
  171. On Error GoTo SendFiletoServer_Err
  172. FTP.UserName = modSettings.strLogin
  173. FTP.Password = modSettings.strPassword
  174. FTP.RemoteAddress = modSettings.strUrl
  175. FTP.LocalFile = modSettings.strSource
  176. FTP.RemoteFile = modSettings.strRemote
  177. FTP.Connect
  178. FTP.PutFile
  179. 'Wait until data is transferred..
  180. '-------------------------
  181. FTP.Disconnect
  182. FileSend = False
  183. Exit Sub
  184. SendFiletoServer_Err:
  185.     MsgBox "Unable To Connect To FTP Server"
  186.     Resume Next
  187. End Sub
  188. Function HTMLData(str As String) As String
  189. pos = InStr(1, Text, "var IPADR =", vbTextCompare)
  190. '----------------- Check if the EXACT data   "var IPADR ="  exist... otherwise the file is not correct !!
  191. If pos = 0 Then GoTo FileCorrupt
  192. pos1 = InStr(pos, Text, "'", vbTextCompare)
  193. pos2 = InStr(pos1 + 1, Text, "'", vbTextCompare)
  194. Txt1 = Mid(Text, 1, pos1)
  195. Txt2 = Mid(Text, pos2, Len(Text))
  196. TotalTXT = Txt1 & str & Txt2
  197. HTMLData = TotalTXT
  198. Exit Function
  199. FileCorrupt:
  200. MsgBox "File is corrupt ! Use the index.html file included in the ZIP file !!!"
  201. HTMLData = "ERROR"
  202. End Function
  203. Public Sub CreateIcon()
  204.     Dim Tic As NOTIFYICONDATA
  205.     Tic.cbSize = Len(Tic)
  206.     Tic.hwnd = Picture1.hwnd
  207.     Tic.uID = 1&
  208.     Tic.uFlags = NIF_DOALL
  209.     Tic.uCallbackMessage = WM_MOUSEMOVE
  210.     Tic.hIcon = Picture1.Picture
  211.     Tic.szTip = "WebRelink " & Chr$(0)
  212.     erg = Shell_NotifyIcon(NIM_ADD, Tic)
  213. End Sub
  214. Public Sub DeleteIcon()
  215.     Dim Tic As NOTIFYICONDATA
  216.     Tic.cbSize = Len(Tic)
  217.     Tic.hwnd = Picture1.hwnd
  218.     Tic.uID = 1&
  219.     erg = Shell_NotifyIcon(NIM_DELETE, Tic)
  220. End Sub
  221. Private Sub Form_Terminate()
  222. DeleteIcon
  223. End Sub
  224. Private Sub Form_Unload(Cancel As Integer)
  225. DeleteIcon
  226. End Sub
  227. Private Sub FTP_TransferProgress(ByVal BytesTransferred As Long, ByVal TotalBytes As Long)
  228. If BytesTransferred = TotalBytes Then FileSend = True
  229. End Sub
  230. Private Sub mnuAbout_Click()
  231. frmAbout.Show
  232. End Sub
  233. Private Sub mnuExit_Click()
  234. Unload Me
  235. End Sub
  236. Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  237.     X = X / Screen.TwipsPerPixelX
  238.     Select Case X
  239.         Case WM_LBUTTONDOWN
  240.         
  241.         Case WM_RBUTTONDOWN
  242.         
  243.         PopupMenu mnuPWS
  244.         Case WM_MOUSEMOVE
  245.         
  246.         Case WM_LBUTTONDBLCLK
  247.         
  248.     End Select
  249. End Sub
  250. Private Sub Settings_Click()
  251. Dialog.Show
  252. End Sub
  253. Private Sub StartRelink_Click()
  254. '---------------------------- CHECK if THE LOCAL FILE IS CORRECT !!!!-------------------
  255. '----------- check if File Exist..
  256.   Set fso1 = CreateObject("Scripting.FileSystemObject")
  257.    If (fso1.FileExists(modSettings.strSource)) Then
  258.    'Okay .... file Exist...
  259.    Else
  260.    MsgBox "Source file " & modSettings.strSource & "  NOT found !!  Check & change the Settings !! ", vbCritical
  261.    GoTo End2:
  262.    End If
  263. '----------------------------------
  264. Dim IPADR As String
  265. IPADR = WS1.LocalIP
  266. Set f = fso1.OpenTextFile(modSettings.strSource, ForReading)
  267.     Text = f.ReadAll
  268.     f.Close
  269. 'Data is read in txt...
  270. Text = HTMLData(IPADR)  'change te data - strings..
  271. 'Save data
  272. If Text <> "ERROR" Then
  273.    'Check if the Remotepath & file > len(0)
  274.    If modSettings.strRemote = "" Then
  275.    MsgBox "You have to fill down a path & file !!", vbCritical
  276.    Exit Sub
  277.    End If
  278. Set a = fso1.CreateTextFile(modSettings.strSource, True)
  279.     a.Write Text
  280.     a.Close
  281. StopRelink.Visible = True
  282. StartRelink.Visible = False
  283. SendFiletoServer
  284. MsgBox "Did you fixed the contents of the file ?" & vbCrLf & modSettings.strSource, vbInformation
  285. End If
  286. End2:
  287. End Sub
  288. Private Sub StopRelink_Click()
  289. Dim IPADR As String
  290. IPADR = "NONE"
  291. 'Data Read
  292. Text = HTMLData(IPADR)
  293. 'Data changed
  294. Set a = fso1.CreateTextFile(modSettings.strSource, True)
  295.     a.Write Text
  296.     a.Close
  297. StopRelink.Visible = False
  298. StartRelink.Visible = True
  299. SendFiletoServer
  300. End Sub
  301.